home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / IFF / ilbm_parser < prev    next >
Encoding:
Text File  |  1992-01-22  |  3.3 KB  |  153 lines
  1. \ Process an ILBM FORM
  2. \
  3. \ Parse an ILBM file by saving parts of the file in allocated
  4. \ memory then processing them after file read.
  5. \
  6. \ Allow vectoring of parser using deferred words.
  7. \
  8. \ Author: Phil Burk
  9. \ Copyright 1988 Phil Burk
  10. \
  11. \ MOD: PLB 2/28/90 Added DEFAULT_CAMG
  12. \ 00001 PLB 11/14/91 Improve error handling,
  13. \    change $ILBM.PARSE.FILE to $ILBM.PARSE.FILE?
  14. \ MOD: PLB 1/22/92 Removed def of FREEVAR
  15.  
  16. include? AllocRaster() ju:graph_support
  17. include? { ju:locals
  18. include? unpackrow jiff:unpacking
  19. include? iff.read jiff:iff_support
  20. decimal
  21. ANEW TASK-ILBM_parser
  22.  
  23. : HEADER>BITMAP ( bitmapheader -- bitmap | NULL , build one based on )
  24.     dup>r ( save bmh )
  25.     ..@ bmh_nplanes
  26.     r@ ..@ bmh_w
  27.     r> ..@ bmh_h
  28.     3 xdup * * 0= abort" HEADER>BITMAP - BitMapHeader has zeroes!"
  29.     alloc.bitmap
  30. ;
  31.  
  32. \ Allocate and fill a BitMap based on BMHD and BODY chunk.
  33. : ILBM.MAKE.BITMAP ( body bsize bmheader | bmap -- bitmap | NULL )
  34.     dup header>bitmap ?dup
  35.     IF  swap ..@ bmh_compression body>bitmap
  36.     ELSE 3 xdrop NULL
  37.     THEN
  38. ;
  39.  
  40.  
  41. \ Declare a scratch header if not already present.
  42. .need ILBM-Header
  43. BitMapHeader ILBM-Header
  44. .THEN
  45.  
  46. variable ILBM-BODY   ( address of alocated BODY )
  47. variable ILBM-BSIZE  ( size of BODY )
  48. variable ILBM-CMAP   ( address of allocated CMAP )
  49. variable ILBM-CMSIZE ( size in bytes of CAMP )
  50. variable ILBM-GRABXY ( contains short x and y )
  51. variable ILBM-CAMG   ( contains actual CAMG data )
  52.  
  53. : ILBM.CLEANUP ( -- , free any data allocated )
  54.     ilbm-cmap freevar
  55.     ilbm-body freevar
  56. ;
  57.  
  58. \ Deferred word for processing unknown chunks.
  59. defer ILBM.OTHER.HANDLER
  60.  
  61. : ILBM.HANDLER ( size chkid -- , default handler used to parse )
  62.     CASE
  63.         'BMHD'
  64.         OF ilbm-header sizeof() BitMapHeader iff.read -
  65.             IF ." ILBM.HANDLER - Oddly sized BitMapHeader!" cr
  66.                 goto.error \ 00001
  67.             THEN
  68.         ENDOF
  69.         'BODY'
  70.         OF dup ilbm-bsize !
  71.             iff.read.data dup ilbm-body !
  72.             0= ?goto.error
  73.         ENDOF
  74.         'CMAP'
  75.         OF dup ilbm-cmsize !
  76.             iff.read.data dup ilbm-cmap !
  77.             0= ?goto.error
  78.         ENDOF
  79.         'GRAB'
  80.         OF ilbm-grabxy 4 iff.read -
  81.             IF ." Oddly sized GRAB" cr
  82.                 goto.error
  83.             THEN
  84.         ENDOF
  85.         'CAMG'
  86.         OF ilbm-camg 4 iff.read -
  87.             IF ." Oddly sized CAMG" cr
  88.                 goto.error
  89.             THEN
  90.         ENDOF
  91.         ( -- size chkid )
  92.         tuck ilbm.other.handler
  93.     ENDCASE
  94.     exit
  95. \
  96. ERROR:
  97.     iff-stop on
  98.     iff-error on
  99. ;
  100.  
  101. : ILBM.PARSER ( size chkid -- , recursively parse ILBM )
  102.     2dup iff.special?
  103.     IF 2drop
  104.     ELSE ( -- size chkid )
  105.         ilbm.handler
  106.     THEN
  107. ;
  108.  
  109. : ILBM.MAKE.CTABLE  ( -- ctable num_colors | 0 0 , allocate from CMAP )
  110.     ilbm-cmap @
  111.     IF  memf_clear ilbm-cmsize @ 3 / dup>r 2* allocblock ?dup
  112.         IF ( -- ctable )
  113.             dup ilbm-cmap @ swap r@ cmap>ctable  ( fill ctable )
  114.             r>  ( -- ctable n )
  115.         ELSE rdrop ." Couldn't allocate CTABLE" cr 0 0
  116.         THEN
  117.     ELSE 0 0
  118.     THEN
  119. ;
  120.  
  121. : ILBM.ALLOC.BITMAP ( -- bitmap | 0)
  122.     ilbm-header header>bitmap ( bitmap )
  123. ;
  124.  
  125. : ILBM.FILL.BITMAP ( bitmap -- bitmap | 0)
  126.     ilbm-body @ 0=
  127.     IF ." No Body" cr 0 RETURN
  128.     THEN
  129. \
  130.     >r ilbm-body @ ilbm-bsize @ r>
  131.     ilbm-header ..@ bmh_compression
  132.     body>bitmap ( bitmap | 0 )
  133. ;
  134.  
  135. : ILBM.INIT ( -- , set vectors )
  136.     ilbm.cleanup
  137.     ' ilbm.parser is iff.process.chunk
  138.     ' iff.not.proc is ilbm.other.handler
  139. ;
  140.  
  141. ilbm.init
  142.  
  143. 0 value DEFAULT_CAMG
  144.  
  145. : $ILBM.PARSE.FILE? ( $filename -- error? , parse an IFF file )
  146.     ilbm-cmap @ warning" CMAP was still allocated!"
  147.     ilbm-body @ warning" BODY was still allocated!"
  148.     0 ilbm-grabxy !
  149.     default_camg ilbm-camg !
  150.     ilbm-header sizeof() BitMapHeader erase
  151.     $iff.dofile?
  152. ;
  153.